home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / select.scm < prev    next >
Text File  |  1995-10-28  |  4KB  |  137 lines
  1. ;;; select(2) syscall for scsh. -*- Scheme -*-
  2. ;;; Copyright (c) 1995 by Olin Shivers.
  3.  
  4. (foreign-source
  5.   "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  6.   "#include \"select1.h\""
  7.   "" "")
  8.  
  9. ;;; TIMEOUT is 0 for immediate, >0 for timeout, #f for infinite; 
  10. ;;;     default is #f.
  11. ;;; The sets are vectors of file descriptors & fd ports.
  12. ;;; You get three new vectors back.
  13.  
  14. (define (select read-vec write-vec exception-vec . maybe-timeout)
  15.   (let ((rv (copy-vector read-vec))
  16.     (wv (copy-vector write-vec))
  17.     (ev (copy-vector exception-vec)))
  18.     (receive (nr nw ne) (apply select!/copyback rv wv ev maybe-timeout)
  19.       (values (vector-take rv nr)
  20.           (vector-take wv nw)
  21.           (vector-take ev ne)))))
  22.  
  23.  
  24. (define (select!/copyback read-vec write-vec exception-vec . maybe-timeout)
  25.   (receive (errno nr nw ne)
  26.            (apply select!/copyback/errno read-vec write-vec exception-vec
  27.                                  maybe-timeout)
  28.      (if errno
  29.      (apply errno-error errno select!/copyback
  30.         read-vec write-vec exception-vec maybe-timeout)
  31.      (values nr nw ne))))
  32.  
  33.  
  34. (define (select!/copyback/errno read-vec write-vec
  35.                 exception-vec . maybe-timeout)
  36.   (let ((timeout (and (pair? maybe-timeout)
  37.               (if (pair? (cdr maybe-timeout))
  38.               (apply error "Too many arguments"
  39.                  select!/copyback/errno
  40.                  read-vec write-vec exception-vec
  41.                  maybe-timeout)
  42.               (real->exact-integer (check-arg real?
  43.                               (car maybe-timeout)
  44.                               select!/copyback/errno)))))
  45.              
  46.     (vec-ok? (lambda (v)
  47.            (vector-every? (lambda (elt)
  48.                     (or (and (integer? elt) (>= elt 0))
  49.                     (fdport? elt)))
  50.                   v))))
  51.     ;; Type-check input vectors.
  52.     (check-arg vec-ok?      read-vec select!/copyback/errno)
  53.     (check-arg vec-ok?     write-vec select!/copyback/errno)
  54.     (check-arg vec-ok? exception-vec select!/copyback/errno)
  55.     (check-arg (lambda (x) (or (not x) (integer? x))) timeout
  56.            select!/copyback/errno)
  57.  
  58.     (let lp ()
  59.       (receive (errno nr nw ne)
  60.            (%select/copyback/errno read-vec write-vec exception-vec timeout)
  61.     (if (and errno (= errno errno/intr))    ; Retry on interrupts.
  62.         (lp)
  63.         (values errno nr nw ne))))))
  64.  
  65.  
  66. (define-foreign %select/copyback/errno
  67.   (select_copyback (vector-desc rvec)
  68.            (vector-desc wvec)
  69.            (vector-desc evec)
  70.            (desc nsecs))    ; Integer or #f for infinity.
  71.   desc        ; errno or #f
  72.   fixnum    ; nread   - number of hits in RVEC
  73.   fixnum    ; nwrite  - number of hits in WVEC
  74.   fixnum)    ; nexcept - number of hits in EVEC
  75.  
  76.  
  77. (define (vector-take vec nelts)
  78.   (let ((short (make-vector nelts)))
  79.     (do ((i (- nelts 1) (- i 1)))
  80.     ((< i 0))
  81.       (vector-set! short i (vector-ref vec i)))
  82.     short))
  83.  
  84.  
  85. ;;; SELECT!
  86. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87. ;;; The side-effecting variant. To be documented.
  88.  
  89. (define (select! read-vec write-vec exception-vec . maybe-timeout)
  90.   (receive (errno nr nw ne)
  91.            (apply select!/errno read-vec write-vec exception-vec maybe-timeout)
  92.      (if errno
  93.      (apply errno-error errno select! read-vec write-vec exception-vec
  94.         maybe-timeout)
  95.      (values nr nw ne))))
  96.  
  97. (define (select!/errno read-vec write-vec exception-vec . maybe-timeout)
  98.   (let ((timeout (and (pair? maybe-timeout)
  99.               (if (pair? (cdr maybe-timeout))
  100.               (apply error "Too many arguments"
  101.                  select!/copyback/errno
  102.                  read-vec write-vec exception-vec
  103.                  maybe-timeout)
  104.               (real->exact-integer (check-arg real?
  105.                               (car maybe-timeout)
  106.                               select!/copyback/errno)))))
  107.              
  108.     (vec-ok? (lambda (v)
  109.            (vector-every? (lambda (elt)
  110.                     (or (and (integer? elt) (>= elt 0))
  111.                     (not elt)
  112.                     (fdport? elt)))
  113.                   v))))
  114.     ;; Type-check input vectors.
  115.     (check-arg vec-ok?      read-vec select!/errno)
  116.     (check-arg vec-ok?     write-vec select!/errno)
  117.     (check-arg vec-ok? exception-vec select!/errno)
  118.     (check-arg (lambda (x) (or (not x) (integer? x))) timeout select!/errno)
  119.     
  120.     (let lp ()
  121.       (receive (errno nr nw ne)
  122.            (%select!/errno read-vec write-vec exception-vec timeout)
  123.     (if (and errno (= errno errno/intr))    ; Retry on interrupts.
  124.         (lp)
  125.         (values errno nr nw ne))))))
  126.  
  127.  
  128. (define-foreign %select!/errno
  129.   (select_filter (vector-desc rvec)
  130.          (vector-desc wvec)
  131.          (vector-desc evec)
  132.          (desc nsecs))        ; Integer or #f for infinity.
  133.   desc        ; errno or #f
  134.   fixnum    ; nread   - number of hits in RVEC
  135.   fixnum    ; nwrite  - number of hits in WVEC
  136.   fixnum)    ; nexcept - number of hits in EVEC
  137.